"
Tests to enforce proper categorization of methods
"
Class {
	#name : 'ProperMethodCategorizationTest',
	#superclass : 'TestCase',
	#category : 'ReleaseTests-Categorization',
	#package : 'ReleaseTests',
	#tag : 'Categorization'
}

{ #category : 'utilities' }
ProperMethodCategorizationTest >> assureAll: selector areCategorizedIn: protocol whenSubclassOf: aClass [

	| violating |
	violating := OrderedCollection new.
	aClass allSubclassesDo: [:cls | cls methods do: [:method |
			(method selector = selector and: [ method protocolName ~= protocol ])
				ifTrue: [ violating add: method -> method protocolName ] ] ].
	self
		assert: violating isEmpty
		description: ('Violations: {1}.
		Reason: {1} subclasses should have #{2} in protocol {3}'
			format: { self explanationFrom: violating . aClass asString. selector. protocol })
]

{ #category : 'utilities' }
ProperMethodCategorizationTest >> assureAll: selector areCategorizedInProtocols: protocols whenSubclassOf: aClass [
	"Test whether the selector is categorized in at least the collection of protocols"

	| violating |
	violating := OrderedCollection new.
	aClass allSubclassesDo: [ :cls |
		cls methods do: [ :method |
			(method selector = selector and: [ (protocols includes: method protocolName) not ]) ifTrue: [ violating add: method -> method protocolName ] ] ].
	self assert: violating isEmpty description: ('Violations are: {1}.
		Reason: {2} subclasses should have #{3} in protocols: {4}' format: {
				 (self explanationFrom: violating).
				 aClass asString.
				 selector.
				 protocols })
]

{ #category : 'utilities' }
ProperMethodCategorizationTest >> explanationFrom: violations [

	^ (String streamContents: [:str |
				violations do: [:association | association key printOn: str]
					separatedBy: [ str nextPutAll: ' ,'] ])
]

{ #category : 'tests - instance creation' }
ProperMethodCategorizationTest >> testBasicNewMethodNeedsToBeInInstanceCreationProtocol [
	"The #basicNew methods should be in method protocol 'instance creation'"

	self assureAll: #basicNew areCategorizedIn: #'instance creation' whenSubclassOf: Object class
]

{ #category : 'tests - initialization' }
ProperMethodCategorizationTest >> testClassSideInitializeMethodNeedsToBeInClassInitializationProtocol [
	"The class side #initialize methods should be in method protocol 'class initialization'"

	| violating classSideInitializeMethods |
	violating := OrderedCollection new.
	classSideInitializeMethods := OrderedCollection new.

	Object allSubclassesDo: [:cls | 
		cls methods do: [:method | 
			(method selector = #initialize and: [ method isClassSide and: [( method package name beginsWith: 'SmalltalkCI') not ] ])
				ifTrue: [ classSideInitializeMethods add: method ]]].
	violating := classSideInitializeMethods select: [:m | m protocolName ~= #'class initialization' ].

	self assert: violating isEmpty description: 'Class side #initialize methods should be in "class initialization" method category:' , violating asString
]

{ #category : 'tests - object' }
ProperMethodCategorizationTest >> testCloneMethodNeedsToBeInCopyingProtocol [
	"The #clone methods should be in method protocol 'copying'"

	self assureAll: #clone areCategorizedIn: #copying whenSubclassOf: Object
]

{ #category : 'tests - object' }
ProperMethodCategorizationTest >> testCopyMethodNeedsToBeInCopyingProtocol [
	"The #copy methods should be in method protocol 'copying'"

	self assureAll: #copy areCategorizedIn: #copying whenSubclassOf: Object
]

{ #category : 'tests - object' }
ProperMethodCategorizationTest >> testDeepCopyMethodNeedsToBeInCopyingProtocol [
	"The #deepCopy methods should be in method protocol 'copying'"

	self assureAll: #deepCopy areCategorizedIn: #copying whenSubclassOf: Object
]

{ #category : 'tests - object' }
ProperMethodCategorizationTest >> testEqualMethodNeedsToBeInComparingProtocol [
	"The #= method should be in method protocol 'comparing'"

	self assureAll: #= areCategorizedIn: #comparing whenSubclassOf: Object
]

{ #category : 'tests - object' }
ProperMethodCategorizationTest >> testFinalizeMethodNeedsToBeInComparingProtocol [
	"The #finalize method should be in method protocol 'finalization'"

	self assureAll: #finalize areCategorizedIn: #finalization whenSubclassOf: Object
]

{ #category : 'tests - object' }
ProperMethodCategorizationTest >> testHashMethodNeedsToBeInComparingProtocol [
	"The #hash method should be in method protocol 'comparing'"

	self assureAll: #hash areCategorizedIn: #comparing whenSubclassOf: Object
]

{ #category : 'tests - initialization' }
ProperMethodCategorizationTest >> testInstanceSideInitializeMethodNeedsToBeInInitializationProtocol [
	"The instance side #initialize methods should be in method protocol 'initialization'"

	| violating instanceSideInitializeMethods |
	violating := OrderedCollection new.
	instanceSideInitializeMethods := OrderedCollection new.

	Object allSubclassesDo: [ :cls |
		cls methods do: [ :method |
			(method selector = #initialize and: [ method isClassSide not and: [ (method package name beginsWith: 'SmalltalkCI') not ] ]) ifTrue: [
				instanceSideInitializeMethods add: method ] ] ].

	"NSLnScale is an external project and is the last failure of this test."
	violating := instanceSideInitializeMethods select: [ :m | m protocolName ~= #initialization and: [ (m methodClass name = 'NSLnScale') not ] ].

	self assert: violating isEmpty description: 'Instance side #initialize methods should be in "initialization" method category:' , violating asString
]

{ #category : 'tests' }
ProperMethodCategorizationTest >> testNoEmptyProtocols [
	"Check that we have no protocols left without methods"

	| violations |
	violations := Dictionary new.
	ProtoObject withAllSubclasses do: [ :cls |
		(cls protocols select: [ :protocol | protocol isEmpty ]) ifNotEmpty: [ :emptyProtocols | violations at: cls put: emptyProtocols ] ].

	self assertEmpty: violations
]

{ #category : 'tests' }
ProperMethodCategorizationTest >> testNoLeadingOrTrailingSpacesInCategoryNames [
	"Make sure we have no protocol names with leading or trailing spaces"

	| violations |
	violations := OrderedCollection new.

	Object allSubclasses do: [ :subclass |
		subclass protocolNames do: [ :protocolName | ((protocolName endsWith: ' ') or: [ protocolName endsWith: ' ' ]) ifTrue: [ violations add: subclass -> protocolName ] ] ].

	self assert: violations isEmpty description: 'Found protocol names with leading or trailing spaces: ' , violations asString
]

{ #category : 'tests' }
ProperMethodCategorizationTest >> testNoUncategorizedMethods [
	"Check that we have no #'as yet unclassified' protocols left"

	| violating validExceptions remaining |
	"We reject protocols containing only methods from Traits because in some rare cases with traits and extension methods we can have methods we cannot categorize."
	violating := Smalltalk globals allBehaviors select: [ :class |
		             class protocols anySatisfy: [ :protocol |
			             protocol isUnclassifiedProtocol and: [ protocol methods anySatisfy: [ :method | method isFromTrait not ] ] ] ].


	validExceptions := #( ClyClass2FromP1Mock #MCMock #'MCMock class' #'MCMockASubclass class' #'MCMockClassA class' #MCMockASubclass #MCMockClassD #'MCMockClassE class'
	                      MFClassA MFClassB RBSmalllintTestObject 'RBTransformationRuleTestData1' StInspectorMockObjectSubclass ).

	remaining := violating asOrderedCollection reject: [ :each | validExceptions includes: each name ].

	self assert: remaining isEmpty description: 'the following classes have uncategorized methods: ' , remaining asString
]

{ #category : 'tests' }
ProperMethodCategorizationTest >> testNoUtilsMethods [
	"Check that we have no #'utils' protocols left, the protocol should be 'utilities' "

	| violating |
	violating := Smalltalk globals allBehaviors select: [ :class | class protocolNames includes: #utils ].

	"we lock in the number of problematic classes, this way it can only improve"
	self assert: violating size <= 4 description: '#utils protocols left, the protocol should be ''utilities'': ' , violating asString
]

{ #category : 'tests - object' }
ProperMethodCategorizationTest >> testPostCopyMethodNeedsToBeInCopyingProtocol [
	"The #postCopy methods should be in method protocol 'copying'"

	self assureAll: #postCopy areCategorizedIn: #copying whenSubclassOf: Object
]

{ #category : 'tests - sunit' }
ProperMethodCategorizationTest >> testRunCaseMethodInSUnitTestsNeedsToBeInRunningProtocol [
	"The #tearDown method in SUnit test classes should be in method protocol 'running'"

	self assureAll: #runCase areCategorizedIn: #running whenSubclassOf: TestCase
]

{ #category : 'tests - sunit' }
ProperMethodCategorizationTest >> testSetUpMethodInSUnitTestsNeedsToBeInRunningProtocol [
	"The #setUp method in SUnit test classes should be in method protocol 'running'"

	self assureAll: #setUp areCategorizedInProtocols: #(#running) whenSubclassOf: TestCase
]

{ #category : 'tests - object' }
ProperMethodCategorizationTest >> testShallowCopyMethodNeedsToBeInCopyingProtocol [
	"The #shallowCopy methods should be in method protocol 'copying'"

	self assureAll: #shallowCopy areCategorizedIn: #copying whenSubclassOf: Object
]

{ #category : 'tests - private' }
ProperMethodCategorizationTest >> testSpeciesMethodNeedsToBeInPrivateProtocol [
	"The #species methods should be in method protocol 'private'"

	self assureAll: #species areCategorizedIn: #private whenSubclassOf: Object
]

{ #category : 'tests - sunit' }
ProperMethodCategorizationTest >> testTearDownMethodInSUnitTestsNeedsToBeInRunningProtocol [
	"The #tearDown method in SUnit test classes should be in method protocol 'running'"

	self assureAll: #tearDown areCategorizedInProtocols: #(#running) whenSubclassOf: TestCase
]

{ #category : 'tests - object' }
ProperMethodCategorizationTest >> testVeryDeepCopyMethodNeedsToBeInCopyingProtocol [
	"The #veryDeepCopy methods should be in method protocol 'copying'"

	self assureAll: #veryDeepCopy areCategorizedIn: #copying whenSubclassOf: Object
]
